Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume24/gnucalc/part16

Text File | 1991-10-29 | 55.2 KB | 1,785 lines

Newsgroups: comp.sources.misc
From: [e-mail] (David Gillespie)
Subject:  v24i064:  gnucalc - GNU Emacs Calculator, v2.00, Part16/56
Message-ID: <[e-mail]>
X-Md4-Signature: ca3abfce3d6b5a9e4d3e498bd6dbb96d
Date: Tue, 29 Oct 1991 23:03:23 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (David Gillespie)
Posting-number: Volume 24, Issue 64
Archive-name: gnucalc/part16
Environment: Emacs
Supersedes: gmcalc: Volume 13, Issue 27-45

---- Cut Here and unpack ----
#!/bin/sh
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc-forms.el continued
#
if test ! -r _shar_seq_.tmp; then
    echo 'Please unpack part 1 first!'
    exit 1
fi
(read Scheck
 if test "$Scheck" != 16; then
    echo Please unpack part "$Scheck" next!
    exit 1
 else
    exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
    echo 'x - still skipping calc-forms.el'
else
echo 'x - continuing file calc-forms.el'
sed 's/^X//' << 'SHAR_EOF' >> 'calc-forms.el' &&
X  (if (or (< day 1) (> day (math-days-in-month year month)))
X      (throw 'syntax "Day value is out of range"))
X  (and hour
X       (progn
X     (if (or (< hour 0) (> hour 23))
X         (throw 'syntax "Hour value is out of range"))
X     (if (or (< minute 0) (> minute 59))
X         (throw 'syntax "Minute value is out of range"))
X     (if (or (math-negp second) (not (Math-lessp second 60)))
X         (throw 'syntax "Seconds value is out of range"))))
X  (list 'date (math-dt-to-date (append (list year month day)
X                       (and hour (list hour minute second)))))
)
X
(defun math-parse-date-word (names &optional front)
X  (let ((n 1))
X    (while (and names (not (string-match (if (equal (car names) "Sep")
X                         "Sept?"
X                       (regexp-quote (car names)))
X                     str)))
X      (setq names (cdr names)
X        n (1+ n)))
X    (and names
X     (or (not front) (= (match-beginning 0) 0))
X     (progn
X       (setq str (concat (substring str 0 (match-beginning 0))
X                 (if front "" " ")
X                 (substring str (match-end 0))))
X       n)))
)
X
(defun math-parse-standard-date (str with-time)
X  (let ((case-fold-search t)
X    (okay t) num
X    (fmt calc-date-format) this next (gnext nil)
X    (year nil) (month nil) (day nil) (bigyear nil) (yearday nil)
X    (hour nil) (minute nil) (second nil) (bc-flag nil))
X    (while (and fmt okay)
X      (setq this (car fmt)
X        fmt (setq fmt (or (cdr fmt)
X                (prog1
X                    gnext
X                  (setq gnext nil))))
X        next (car fmt))
X      (if (consp next) (setq next (car next)))
X      (or (cond ((listp this)
X         (or (not with-time)
X             (not this)
X             (setq gnext fmt
X               fmt this)))
X        ((stringp this)
X         (if (and (<= (length this) (length str))
X              (equal this
X                 (substring str 0 (length this))))
X             (setq str (substring str (length this)))))
X        ((eq this 'X)
X         t)
X        ((memq this '(n N j J))
X         (and (string-match "\\`[-+]?[0-9.]+\\([eE][-+]?[0-9]+\\)?" str)
X              (setq num (math-match-substring str 0)
X                str (substring str (match-end 0))
X                num (math-date-to-dt (math-read-number num))
X                num (math-sub num
X                      (if (memq this '(n N))
X                          0
X                        (if (or (eq this 'j)
X                            (math-integerp num))
X                        '(bigpos 424 721 1)
X                          '(float (bigpos 235 214 17)
X                              -1))))
X                hour (or (nth 3 num) hour)
X                minute (or (nth 4 num) minute)
X                second (or (nth 5 num) second)
X                year (car num)
X                month (nth 1 num)
X                day (nth 2 num))))
X        ((eq this 'U)
X         (and (string-match "\\`[-+]?[0-9]+" str)
X              (setq num (math-match-substring str 0)
X                str (substring str (match-end 0))
X                num (math-date-to-dt
X                 (math-add 719164
X                       (math-div (math-read-number num)
X                             '(float 864 2))))
X                hour (nth 3 num)
X                minute (nth 4 num)
X                second (nth 5 num)
X                year (car num)
X                month (nth 1 num)
X                day (nth 2 num))))
X        ((memq this '(Mmm MMM))
X         (setq month (math-parse-date-word math-short-month-names t)))
X        ((memq this '(Mmmm MMMM))
X         (setq month (math-parse-date-word math-long-month-names t)))
X        ((memq this '(Www WWW))
X         (math-parse-date-word math-short-weekday-names t))
X        ((memq this '(Wwww WWWW))
X         (math-parse-date-word math-long-weekday-names t))
X        ((memq this '(p P))
X         (if (string-match "\\`a" str)
X             (setq hour (if (= hour 12) 0 hour)
X               str (substring str 1))
X           (if (string-match "\\`p" str)
X               (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
X                 str (substring str 1)))))
X        ((memq this '(pp PP pppp PPPP))
X         (if (string-match "\\`am\\|a\\.m\\." str)
X             (setq hour (if (= hour 12) 0 hour)
X               str (substring str (match-end 0)))
X           (if (string-match "\\`pm\\|p\\.m\\." str)
X               (setq hour (if (= hour 12) 12 (% (+ hour 12) 24))
X                 str (substring str (match-end 0))))))
X        ((memq this '(Y YY BY YYY YYYY))
X         (and (if (memq next '(MM DD ddd hh HH mm ss SS))
X              (if (memq this '(Y YY BYY))
X                  (string-match "\\` *[0-9][0-9]" str)
X                (string-match "\\`[0-9][0-9][0-9][0-9]" str))
X            (string-match "\\`[-+]?[0-9]+" str))
X              (setq year (math-match-substring str 0)
X                bigyear (or (eq this 'YYY)
X                    (memq (aref str 0) '(?\+ ?\-)))
X                str (substring str (match-end 0))
X                year (math-read-number year))))
X        ((eq this 'b)
X         t)
X        ((memq this '(aa AA aaaa AAAA))
X         (if (string-match "\\` *\\(ad\\|a\\.d\\.\\)" str)
X             (setq str (substring str (match-end 0)))))
X        ((memq this '(aaa AAA))
X         (if (string-match "\\` *ad *" str)
X             (setq str (substring str (match-end 0)))))
X        ((memq this '(bb BB bbb BBB bbbb BBBB))
X         (if (string-match "\\` *\\(bc\\|b\\.c\\.\\)" str)
X             (setq str (substring str (match-end 0))
X               bc-flag t)))
X        ((memq this '(s ss bs SS BS))
X         (and (if (memq next '(YY YYYY MM DD hh HH mm))
X              (string-match "\\` *[0-9][0-9]\\(\\.[0-9]+\\)?" str)
X            (string-match "\\` *[0-9][0-9]?\\(\\.[0-9]+\\)?" str))
X              (setq second (math-match-substring str 0)
X                str (substring str (match-end 0))
X                second (math-read-number second))))
X        ((eq this 'C)
X         (if (string-match "\\`:[0-9][0-9]" str)
X             (setq str (substring str 1))
X           t))
X        ((or (not (if (and (memq this '(ddd MM DD hh HH mm))
X                   (memq next '(YY YYYY MM DD ddd
X                           hh HH mm ss SS)))
X                  (if (eq this 'ddd)
X                  (string-match "\\` *[0-9][0-9][0-9]" str)
X                (string-match "\\` *[0-9][0-9]" str))
X                (string-match "\\` *[0-9]+" str)))
X             (and (setq num (string-to-int
X                     (math-match-substring str 0))
X                str (substring str (match-end 0)))
X              nil))
X         nil)
X        ((eq this 'W)
X         (and (>= num 0) (< num 7)))
X        ((memq this '(d ddd bdd))
X         (setq yearday num))
X        ((memq this '(M MM BM))
X         (setq month num))
X        ((memq this '(D DD BD))
X         (setq day num))
X        ((memq this '(h hh bh H HH BH))
X         (setq hour num))
X        ((memq this '(m mm bm))
X         (setq minute num)))
X      (setq okay nil)))
X    (if yearday
X    (if (and month day)
X        (setq yearday nil)
X      (setq month 1 day 1)))
X    (if (and okay (equal str ""))
X    (and month day (or (not (or hour minute second))
X               (and hour minute))
X         (progn
X           (or year (setq year (math-this-year)))
X           (or second (setq second 0))
X           (if bc-flag
X           (setq year (math-neg (math-abs year))))
X           (setq day (math-parse-date-validate year bigyear month day
X                           hour minute second))
X           (if yearday
X           (setq day (math-add day (1- yearday))))
X           day))))
)
X
X
(defun calcFunc-now (&optional zone)
X  (let ((date (let ((calc-date-format nil))
X        (math-parse-date (current-time-string)))))
X    (if (consp date)
X    (if zone
X        (math-add date (math-div (math-sub (calcFunc-tzone nil date)
X                           (calcFunc-tzone zone date))
X                     '(float 864 2)))
X      date)
X      (calc-record-why "*Unable to interpret current date from system")
X      (append (list 'calcFunc-now) (and zone (list zone)))))
)
X
(defun calcFunc-year (date)
X  (car (math-date-to-dt date))
)
X
(defun calcFunc-month (date)
X  (nth 1 (math-date-to-dt date))
)
X
(defun calcFunc-day (date)
X  (nth 2 (math-date-to-dt date))
)
X
(defun calcFunc-weekday (date)
X  (if (eq (car-safe date) 'date)
X      (setq date (nth 1 date)))
X  (or (math-realp date)
X      (math-reject-arg date 'datep))
X  (math-mod (math-add (math-floor date) 6) 7)
)
X
(defun calcFunc-yearday (date)
X  (let ((dt (math-date-to-dt date)))
X    (math-day-number (car dt) (nth 1 dt) (nth 2 dt)))
)
X
(defun calcFunc-hour (date)
X  (if (eq (car-safe date) 'hms)
X      (nth 1 date)
X    (or (nth 3 (math-date-to-dt date)) 0))
)
X
(defun calcFunc-minute (date)
X  (if (eq (car-safe date) 'hms)
X      (nth 2 date)
X    (or (nth 4 (math-date-to-dt date)) 0))
)
X
(defun calcFunc-second (date)
X  (if (eq (car-safe date) 'hms)
X      (nth 3 date)
X    (or (nth 5 (math-date-to-dt date)) 0))
)
X
(defun calcFunc-time (date)
X  (let ((dt (math-date-to-dt date)))
X    (if (nth 3 dt)
X    (cons 'hms (nthcdr 3 dt))
X      (list 'hms 0 0 0)))
)
X
(defun calcFunc-date (date &optional month day hour minute second)
X  (and (math-messy-integerp month) (setq month (math-trunc month)))
X  (and month (not (integerp month)) (math-reject-arg month 'fixnump))
X  (and (math-messy-integerp day) (setq day (math-trunc day)))
X  (and day (not (integerp day)) (math-reject-arg day 'fixnump))
X  (if (and (eq (car-safe hour) 'hms) (not minute))
X      (setq second (nth 3 hour)
X        minute (nth 2 hour)
X        hour (nth 1 hour)))
X  (and (math-messy-integerp hour) (setq hour (math-trunc hour)))
X  (and hour (not (integerp hour)) (math-reject-arg hour 'fixnump))
X  (and (math-messy-integerp minute) (setq minute (math-trunc minute)))
X  (and minute (not (integerp minute)) (math-reject-arg minute 'fixnump))
X  (and (math-messy-integerp second) (setq second (math-trunc second)))
X  (and second (not (math-realp second)) (math-reject-arg second 'realp))
X  (if month
X      (progn
X    (and (math-messy-integerp date) (setq date (math-trunc date)))
X    (and date (not (math-integerp date)) (math-reject-arg date 'integerp))
X    (if day
X        (if hour
X        (list 'date (math-dt-to-date (list date month day hour
X                           (or minute 0)
X                           (or second 0))))
X          (list 'date (math-dt-to-date (list date month day))))
X      (list 'date (math-dt-to-date (list (math-this-year) date month)))))
X    (if (math-realp date)
X    (list 'date date)
X      (if (eq (car date) 'date)
X      (nth 1 date)
X    (math-reject-arg date 'datep))))
)
X
(defun calcFunc-julian (date &optional zone)
X  (if (math-realp date)
X      (list 'date (if (math-integerp date)
X              (math-sub date '(bigpos 424 721 1))
X            (setq date (math-sub date '(float (bigpos 235 214 17) -1)))
X            (math-sub date (math-div (calcFunc-tzone zone date)
X                         '(float 864 2)))))
X    (if (eq (car date) 'date)
X    (math-add (nth 1 date) (if (math-integerp (nth 1 date))
X                   '(bigpos 424 721 1)
X                 (math-add '(float (bigpos 235 214 17) -1)
X                       (math-div (calcFunc-tzone zone date)
X                             '(float 864 2)))))
X      (math-reject-arg date 'datep)))
)
X
(defun calcFunc-unixtime (date &optional zone)
X  (if (math-realp date)
X      (progn
X    (setq date (math-add 719164 (math-div date '(float 864 2))))
X    (list 'date (math-sub date (math-div (calcFunc-tzone zone date)
X                         '(float 864 2)))))
X    (if (eq (car date) 'date)
X    (math-add (nth 1 (math-date-parts (nth 1 date) 719164))
X          (calcFunc-tzone zone date))
X      (math-reject-arg date 'datep)))
)
X
(defun calcFunc-tzone (&optional zone date)
X  (if zone
X      (cond ((math-realp zone)
X         (math-round (math-mul zone 3600)))
X        ((eq (car zone) 'hms)
X         (math-round (math-mul (math-from-hms zone 'deg) 3600)))
X        ((eq (car zone) '+)
X         (math-add (calcFunc-tzone (nth 1 zone) date)
X               (calcFunc-tzone (nth 2 zone) date)))
X        ((eq (car zone) '-)
X         (math-sub (calcFunc-tzone (nth 1 zone) date)
X               (calcFunc-tzone (nth 2 zone) date)))
X        ((eq (car zone) 'var)
X         (let ((name (upcase (symbol-name (nth 1 zone))))
X           found)
X           (if (setq found (assoc name math-tzone-names))
X           (calcFunc-tzone (math-add (nth 1 found)
X                         (if (integerp (nth 2 found))
X                         (nth 2 found)
X                           (or
X                        (math-daylight-savings-adjust
X                         date (car found))
X                        0)))
X                   date)
X         (if (equal name "LOCAL")
X             (calcFunc-tzone nil date)
X           (math-reject-arg zone "*Unrecognized time zone name")))))
X        (t (math-reject-arg zone "*Expected a time zone")))
X    (if (calc-var-value 'var-TimeZone)
X    (calcFunc-tzone (calc-var-value 'var-TimeZone) date)
X      (let ((p math-tzone-names)
X        (offset 0)
X        (tz '(var error var-error)))
X    (save-excursion
X      (set-buffer (get-buffer-create " *Calc Temporary*"))
X      (erase-buffer)
X      (call-process "date" nil t)
X      (goto-char 1)
X      (let ((case-fold-search t))
X        (while (and p (not (search-forward (car (car p)) nil t)))
X          (setq p (cdr p))))
X      (if (looking-at "\\([-+][0-9]?[0-9]\\)\\([0-9][0-9]\\)?\\(\\'\\|[^0-9]\\)")
X          (setq offset (math-add
X                (string-to-int (buffer-substring
X                        (match-beginning 1)
X                        (match-end 1)))
X                (if (match-beginning 2)
X                (math-div (string-to-int (buffer-substring
X                              (match-beginning 2)
X                              (match-end 2)))
X                      60)
X                  0)))))
X    (if p
X        (progn
X          (setq p (car p))
X          ;; Try to convert to a generalized time zone.
X          (if (integerp (nth 2 p))
X          (let ((gen math-tzone-names))
X            (while (and gen
X                (not (equal (nth 2 (car gen)) (car p)))
X                (not (equal (nth 3 (car gen)) (car p)))
X                (not (equal (nth 4 (car gen)) (car p)))
X                (not (equal (nth 5 (car gen)) (car p))))
X              (setq gen (cdr gen)))
X            (and gen
X             (setq gen (car gen))
X             (equal (math-daylight-savings-adjust nil (car gen))
X                (nth 2 p))
X             (setq p gen))))
X          (setq tz (math-add (list 'var
X                       (intern (car p))
X                       (intern (concat "var-" (car p))))
X                 offset))))
X    (kill-buffer " *Calc Temporary*")
X    (setq var-TimeZone tz)
X    (calc-refresh-evaltos 'var-TimeZone)
X    (calcFunc-tzone tz date))))
)
X
;;; Note: Longer names must appear before shorter names which are
;;;       substrings of them.
(defvar math-tzone-names
X  '( ( "MEGT" -1 "MET" "METDST" )                          ; Middle Europe
X     ( "METDST" -1 -1 ) ( "MET" -1 0 )
X     ( "MEGZ" -1 "MEZ" "MESZ" ) ( "MEZ" -1 0 ) ( "MESZ" -1 -1 )
X     ( "WEGT" 0 "WET" "WETDST" )                           ; Western Europe
X     ( "WETDST" 0 -1 ) ( "WET" 0 0 )
X     ( "BGT" 0 "GMT" "BST" ) ( "GMT" 0 0 ) ( "BST" 0 -1 )  ; Britain
X     ( "NGT" (float 35 -1) "NST" "NDT" )                   ; Newfoundland
X     ( "NST" (float 35 -1) 0 ) ( "NDT" (float 35 -1) -1 )
X     ( "AGT" 4 "AST" "ADT" ) ( "AST" 4 0 ) ( "ADT" 4 -1 )  ; Atlantic
X     ( "EGT" 5 "EST" "EDT" ) ( "EST" 5 0 ) ( "EDT" 5 -1 )  ; Eastern
X     ( "CGT" 6 "CST" "CDT" ) ( "CST" 6 0 ) ( "CDT" 6 -1 )  ; Central
X     ( "MGT" 7 "MST" "MDT" ) ( "MST" 7 0 ) ( "MDT" 7 -1 )  ; Mountain
X     ( "PGT" 8 "PST" "PDT" ) ( "PST" 8 0 ) ( "PDT" 8 -1 )  ; Pacific
X     ( "YGT" 9 "YST" "YDT" ) ( "YST" 9 0 ) ( "YDT" 9 -1 )  ; Yukon
))
X
X
(defun math-daylight-savings-adjust (date zone &optional dt)
X  (or date (setq date (nth 1 (calcFunc-now))))
X  (let (bump)
X    (if (eq (car-safe date) 'date)
X    (setq bump 0
X          date (nth 1 date))
X      (if (and date (math-realp date))
X      (let ((zadj (assoc zone math-tzone-names)))
X        (if zadj (setq bump -1
X               date (math-sub date (math-div (nth 1 zadj)
X                             '(float 24 0))))))
X    (math-reject-arg date 'datep)))
X    (setq date (math-float date))
X    (or dt (setq dt (math-date-to-dt date)))
X    (and math-daylight-savings-hook
X     (funcall math-daylight-savings-hook date dt zone bump)))
)
X
(defun calcFunc-dsadj (date &optional zone)
X  (if zone
X      (or (eq (car-safe zone) 'var)
X      (math-reject-arg zone "*Time zone variable expected"))
X    (setq zone (or (calc-var-value 'var-TimeZone)
X           (progn
X             (calcFunc-tzone)
X             (calc-var-value 'var-TimeZone)))))
X  (setq zone (and (eq (car-safe zone) 'var)
X          (upcase (symbol-name (nth 1 zone)))))
X  (let ((zadj (assoc zone math-tzone-names)))
X    (or zadj (math-reject-arg zone "*Unrecognized time zone name"))
X    (if (integerp (nth 2 zadj))
X    (nth 2 zadj)
X      (math-daylight-savings-adjust date zone)))
)
X
(defun calcFunc-tzconv (date z1 z2)
X  (if (math-realp date)
X      (nth 1 (calcFunc-tzconv (list 'date date) z1 z2))
X    (calcFunc-unixtime (calcFunc-unixtime date z1) z2))
)
X
(defvar math-daylight-savings-hook 'math-std-daylight-savings)
X
(defun math-std-daylight-savings (date dt zone bump)
X  "Standard North American daylight savings algorithm.
This implements the rules for the U.S. and Canada as of 1987.
Daylight savings begins on the first Sunday of April at 2 a.m.,
and ends on the last Sunday of October at 2 a.m."
X  (cond ((< (nth 1 dt) 4) 0)
X    ((= (nth 1 dt) 4)
X     (let ((sunday (math-prev-weekday-in-month date dt 7 0)))
X       (cond ((< (nth 2 dt) sunday) 0)
X         ((= (nth 2 dt) sunday)
X          (if (>= (nth 3 dt) (+ 3 bump)) -1 0))
X         (t -1))))
X    ((< (nth 1 dt) 10) -1)
X    ((= (nth 1 dt) 10)
X     (let ((sunday (math-prev-weekday-in-month date dt 31 0)))
X       (cond ((< (nth 2 dt) sunday) -1)
X         ((= (nth 2 dt) sunday)
X          (if (>= (nth 3 dt) (+ 2 bump)) 0 -1))
X         (t 0))))
X    (t 0))
)
X
;;; Compute the day (1-31) of the WDAY (0-6) on or preceding the given
;;; day of the given month.
(defun math-prev-weekday-in-month (date dt day wday)
X  (or day (setq day (nth 2 dt)))
X  (if (> day (math-days-in-month (car dt) (nth 1 dt)))
X      (setq day (math-days-in-month (car dt) (nth 1 dt))))
X  (let ((zeroth (math-sub (math-floor date) (nth 2 dt))))
X    (math-sub (nth 1 (calcFunc-newweek (math-add zeroth day))) zeroth))
)
X
(defun calcFunc-pwday (date &optional day weekday)
X  (if (eq (car-safe date) 'date)
X      (setq date (nth 1 date)))
X  (or (math-realp date)
X      (math-reject-arg date 'datep))
X  (if (math-messy-integerp day) (setq day (math-trunc day)))
X  (or (integerp day) (math-reject-arg day 'fixnump))
X  (if (= day 0) (setq day 31))
X  (and (or (< day 7) (> day 31)) (math-reject-arg day 'range))
X  (math-prev-weekday-in-month date (math-date-to-dt date) day (or weekday 0))
)
X
X
(defun calcFunc-newweek (date &optional weekday)
X  (if (eq (car-safe date) 'date)
X      (setq date (nth 1 date)))
X  (or (math-realp date)
X      (math-reject-arg date 'datep))
X  (or weekday (setq weekday 0))
X  (and (math-messy-integerp weekday) (setq weekday (math-trunc weekday)))
X  (or (integerp weekday) (math-reject-arg weekday 'fixnump))
X  (and (or (< weekday 0) (> weekday 6)) (math-reject-arg weekday 'range))
X  (setq date (math-floor date))
X  (list 'date (math-sub date (calcFunc-weekday (math-sub date weekday))))
)
X
(defun calcFunc-newmonth (date &optional day)
X  (or day (setq day 1))
X  (and (math-messy-integerp day) (setq day (math-trunc day)))
X  (or (integerp day) (math-reject-arg day 'fixnump))
X  (and (or (< day 0) (> day 31)) (math-reject-arg day 'range))
X  (let ((dt (math-date-to-dt date)))
X    (if (or (= day 0) (> day (math-days-in-month (car dt) (nth 1 dt))))
X    (setq day (math-days-in-month (car dt) (nth 1 dt))))
X    (and (eq (car dt) 1752) (= (nth 1 dt) 9)
X     (if (>= day 14) (setq day (- day 11))))
X    (list 'date (math-add (math-dt-to-date (list (car dt) (nth 1 dt) 1))
X              (1- day))))
)
X
(defun calcFunc-newyear (date &optional day)
X  (or day (setq day 1))
X  (and (math-messy-integerp day) (setq day (math-trunc day)))
X  (or (integerp day) (math-reject-arg day 'fixnump))
X  (let ((dt (math-date-to-dt date)))
X    (if (and (>= day 0) (<= day 366))
X    (let ((max (if (eq (car dt) 1752) 355
X             (if (math-leap-year-p (car dt)) 366 365))))
X      (if (or (= day 0) (> day max)) (setq day max))
X      (list 'date (math-add (math-dt-to-date (list (car dt) 1 1))
X                (1- day))))
X      (if (and (>= day -12) (<= day -1))
X      (list 'date (math-dt-to-date (list (car dt) (- day) 1)))
X    (math-reject-arg day 'range))))
)
X
(defun calcFunc-incmonth (date &optional step)
X  (or step (setq step 1))
X  (and (math-messy-integerp step) (setq step (math-trunc step)))
X  (or (math-integerp step) (math-reject-arg step 'integerp))
X  (let* ((dt (math-date-to-dt date))
X     (year (car dt))
X     (month (math-add (1- (nth 1 dt)) step))
X     (extra (calcFunc-idiv month 12))
X     (day (nth 2 dt)))
X    (setq month (1+ (math-sub month (math-mul extra 12)))
X      year (math-add year extra)
X      day (min day (math-days-in-month year month)))
X    (and (math-posp (car dt)) (not (math-posp year))
X     (setq year (math-sub year 1)))   ; did we go past the year zero?
X    (and (math-negp (car dt)) (not (math-negp year))
X     (setq year (math-add year 1)))
X    (list 'date (math-dt-to-date
X         (cons year (cons month (cons day (cdr (cdr (cdr dt)))))))))
)
X
(defun calcFunc-incyear (date &optional step)
X  (calcFunc-incmonth date (math-mul (or step 1) 12))
)
X
X
X
X
;;;; Error forms.
X
;;; Build a standard deviation form.  [X X X]
(defun math-make-sdev (x sigma)
X  (if (memq (car-safe x) '(date mod sdev intv vec))
X      (math-reject-arg x 'realp))
X  (if (memq (car-safe sigma) '(date mod sdev intv vec))
X      (math-reject-arg sigma 'realp))
X  (if (or (Math-negp sigma) (memq (car-safe sigma) '(cplx polar)))
X      (setq sigma (math-abs sigma)))
X  (if (and (Math-zerop sigma) (Math-scalarp x))
X      x
X    (list 'sdev x sigma))
)
(defun calcFunc-sdev (x sigma)
X  (math-make-sdev x sigma)
)
X
X
X
;;;; Modulo forms.
X
(defun math-normalize-mod (a)
X  (let ((n (math-normalize (nth 1 a)))
X    (m (math-normalize (nth 2 a))))
X    (if (and (math-anglep n) (math-anglep m) (math-posp m))
X    (math-make-mod n m)
X      (math-normalize (list 'calcFunc-makemod n m))))
)
X
;;; Build a modulo form.  [N R R]
(defun math-make-mod (n m)
X  (setq calc-previous-modulo m)
X  (and n
X       (cond ((not (Math-anglep m))
X          (math-reject-arg m 'anglep))
X         ((not (math-posp m))
X          (math-reject-arg m 'posp))
X         ((Math-anglep n)
X          (if (or (Math-negp n)
X              (not (Math-lessp n m)))
X          (list 'mod (math-mod n m) m)
X        (list 'mod n m)))
X         ((memq (car n) '(+ - / vec neg))
X          (math-normalize
X           (cons (car n)
X             (mapcar (function (lambda (x) (math-make-mod x m)))
X                 (cdr n)))))
X         ((and (eq (car n) '*) (Math-anglep (nth 1 n)))
X          (math-mul (math-make-mod (nth 1 n) m) (nth 2 n)))
X         ((memq (car n) '(* ^ var calcFunc-subscr))
X          (math-mul (math-make-mod 1 m) n))
X         (t (math-reject-arg n 'anglep))))
)
(defun calcFunc-makemod (n m)
X  (math-make-mod n m)
)
X
X
X
;;;; Interval forms.
X
;;; Build an interval form.  [X S X X]
(defun math-make-intv (mask lo hi)
X  (if (memq (car-safe lo) '(cplx polar mod sdev intv vec))
X      (math-reject-arg lo 'realp))
X  (if (memq (car-safe hi) '(cplx polar mod sdev intv vec))
X      (math-reject-arg hi 'realp))
X  (or (eq (eq (car-safe lo) 'date) (eq (car-safe hi) 'date))
X      (math-reject-arg (if (eq (car-safe lo) 'date) hi lo) 'datep))
X  (if (and (or (Math-realp lo) (eq (car lo) 'date))
X       (or (Math-realp hi) (eq (car hi) 'date)))
X      (let ((cmp (math-compare lo hi)))
X    (if (= cmp 0)
X        (if (= mask 3)
X        lo
X          (list 'intv mask lo hi))
X      (if (> cmp 0)
X          (if (= mask 3)
X          (list 'intv 2 lo lo)
X        (list 'intv mask lo lo))
X        (list 'intv mask lo hi))))
X    (list 'intv mask lo hi))
)
(defun calcFunc-intv (mask lo hi)
X  (if (math-messy-integerp mask) (setq mask (math-trunc mask)))
X  (or (natnump mask) (math-reject-arg mask 'fixnatnump))
X  (or (<= mask 3) (math-reject-arg mask 'range))
X  (math-make-intv mask lo hi)
)
X
(defun math-sort-intv (mask lo hi)
X  (if (Math-lessp hi lo)
X      (math-make-intv (aref [0 2 1 3] mask) hi lo)
X    (math-make-intv mask lo hi))
)
X
X
X
X
(defun math-combine-intervals (a am b bm c cm d dm)
X  (let (res)
X    (if (= (setq res (math-compare a c)) 1)
X    (setq a c am cm)
X      (if (= res 0)
X      (setq am (or am cm))))
X    (if (= (setq res (math-compare b d)) -1)
X    (setq b d bm dm)
X      (if (= res 0)
X      (setq bm (or bm dm))))
X    (math-make-intv (+ (if am 2 0) (if bm 1 0)) a b))
)
X
X
(defun math-div-mod (a b m)   ; [R R R R]  (Returns nil if no solution)
X  (and (Math-integerp a) (Math-integerp b) (Math-integerp m)
X       (let ((u1 1) (u3 b) (v1 0) (v3 m))
X     (while (not (eq v3 0))   ; See Knuth sec 4.5.2, exercise 15
X       (let* ((q (math-idivmod u3 v3))
X          (t1 (math-sub u1 (math-mul v1 (car q)))))
X         (setq u1 v1  u3 v3  v1 t1  v3 (cdr q))))
X     (let ((q (math-idivmod a u3)))
X       (and (eq (cdr q) 0)
X        (math-mod (math-mul (car q) u1) m)))))
)
X
(defun math-mod-intv (a b)
X  (let* ((q1 (math-floor (math-div (nth 2 a) b)))
X     (q2 (math-floor (math-div (nth 3 a) b)))
X     (m1 (math-sub (nth 2 a) (math-mul q1 b)))
X     (m2 (math-sub (nth 3 a) (math-mul q2 b))))
X    (cond ((equal q1 q2)
X       (math-sort-intv (nth 1 a) m1 m2))
X      ((and (math-equal-int (math-sub q2 q1) 1)
X        (math-zerop m2)
X        (memq (nth 1 a) '(0 2)))
X       (math-make-intv (nth 1 a) m1 b))
X      (t
X       (math-make-intv 2 0 b))))
)
X
X
(defun math-read-angle-brackets ()
X  (let* ((last (or (math-check-for-commas t) (length exp-str)))
X     (str (substring exp-str exp-pos last))
X     (res
X      (if (string-match "\\` *\\([a-zA-Z#][a-zA-Z0-9#]* *,? *\\)*:" str)
X          (let ((str1 (substring str 0 (1- (match-end 0))))
X            (str2 (substring str (match-end 0)))
X            (calc-hashes-used 0))
X        (setq str1 (math-read-expr (concat "[" str1 "]")))
X        (if (eq (car-safe str1) 'error)
X            str1
X          (setq str2 (math-read-expr str2))
X          (if (eq (car-safe str2) 'error)
X              str2
X            (append '(calcFunc-lambda) (cdr str1) (list str2)))))
X        (if (string-match "#" str)
X        (let ((calc-hashes-used 0))
X          (and (setq str (math-read-expr str))
X               (if (eq (car-safe str) 'error)
X               str
X             (append '(calcFunc-lambda)
X                 (calc-invent-args calc-hashes-used)
X                 (list str)))))
X          (math-parse-date str)))))
X    (if (stringp res)
X    (throw 'syntax res))
X    (if (eq (car-safe res) 'error)
X    (throw 'syntax (nth 2 res)))
X    (setq exp-pos (1+ last))
X    (math-read-token)
X    res)
)
X
SHAR_EOF
echo 'File calc-forms.el is complete' &&
chmod 0644 calc-forms.el ||
echo 'restore of calc-forms.el failed'
Wc_c="`wc -c < 'calc-forms.el'`"
test 51626 -eq "$Wc_c" ||
    echo 'calc-forms.el: original size 51626, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-frac.el ==============
if test -f 'calc-frac.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-frac.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-frac.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-frac.el' &&
;; Calculator for GNU Emacs, part II [calc-frac.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-frac () nil)
X
X
(defun calc-fdiv (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op ":" 'calcFunc-fdiv arg 1))
)
X
X
(defun calc-fraction (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (let ((func (if (calc-is-hyperbolic) 'calcFunc-frac 'calcFunc-pfrac)))
X     (if (eq arg 0)
X     (calc-enter-result 2 "frac" (list func
X                       (calc-top-n 2)
X                       (calc-top-n 1)))
X       (calc-enter-result 1 "frac" (list func
X                     (calc-top-n 1)
X                     (prefix-numeric-value (or arg 0)))))))
)
X
X
(defun calc-over-notation (fmt)
X  (interactive "sFraction separator (:, ::, /, //, :/): ")
X  (calc-wrapper
X   (if (string-match "\\`\\([^ 0-9][^ 0-9]?\\)[0-9]*\\'" fmt)
X       (let ((n nil))
X     (if (/= (match-end 0) (match-end 1))
X         (setq n (string-to-int (substring fmt (match-end 1)))
X           fmt (math-match-substring fmt 1)))
X     (if (eq n 0) (error "Bad denominator"))
X     (calc-change-mode 'calc-frac-format (list fmt n) t))
X     (error "Bad fraction separator format.")))
)
X
(defun calc-slash-notation (n)
X  (interactive "P")
X  (calc-wrapper
X   (calc-change-mode 'calc-frac-format (if n '("//" nil) '("/" nil)) t))
)
X
X
(defun calc-frac-mode (n)
X  (interactive "P")
X  (calc-wrapper
X   (calc-change-mode 'calc-prefer-frac n nil t)
X   (message (if calc-prefer-frac
X        "Integer division will now generate fractions."
X          "Integer division will now generate floating-point results.")))
)
X
X
X
X
X
;;;; Fractions.
X
;;; Build a normalized fraction.  [R I I]
;;; (This could probably be implemented more efficiently than using
;;;  the plain gcd algorithm.)
(defun math-make-frac (num den)
X  (if (Math-integer-negp den)
X      (setq num (math-neg num)
X        den (math-neg den)))
X  (let ((gcd (math-gcd num den)))
X    (if (eq gcd 1)
X    (if (eq den 1)
X        num
X      (list 'frac num den))
X      (if (equal gcd den)
X      (math-quotient num gcd)
X    (list 'frac (math-quotient num gcd) (math-quotient den gcd)))))
)
X
(defun calc-add-fractions (a b)
X  (if (eq (car-safe a) 'frac)
X      (if (eq (car-safe b) 'frac)
X      (math-make-frac (math-add (math-mul (nth 1 a) (nth 2 b))
X                    (math-mul (nth 2 a) (nth 1 b)))
X              (math-mul (nth 2 a) (nth 2 b)))
X    (math-make-frac (math-add (nth 1 a)
X                  (math-mul (nth 2 a) b))
X            (nth 2 a)))
X    (math-make-frac (math-add (math-mul a (nth 2 b))
X                  (nth 1 b))
X            (nth 2 b)))
)
X
(defun calc-mul-fractions (a b)
X  (if (eq (car-safe a) 'frac)
X      (if (eq (car-safe b) 'frac)
X      (math-make-frac (math-mul (nth 1 a) (nth 1 b))
X              (math-mul (nth 2 a) (nth 2 b)))
X    (math-make-frac (math-mul (nth 1 a) b)
X            (nth 2 a)))
X    (math-make-frac (math-mul a (nth 1 b))
X            (nth 2 b)))
)
X
(defun calc-div-fractions (a b)
X  (if (eq (car-safe a) 'frac)
X      (if (eq (car-safe b) 'frac)
X      (math-make-frac (math-mul (nth 1 a) (nth 2 b))
X              (math-mul (nth 2 a) (nth 1 b)))
X    (math-make-frac (nth 1 a)
X            (math-mul (nth 2 a) b)))
X    (math-make-frac (math-mul a (nth 2 b))
X            (nth 1 b)))
)
X
X
X
X
;;; Convert a real value to fractional form.  [T R I; T R F] [Public]
(defun calcFunc-frac (a &optional tol)
X  (or tol (setq tol 0))
X  (cond ((Math-ratp a)
X     a)
X    ((memq (car a) '(cplx polar vec hms date sdev intv mod))
X     (cons (car a) (mapcar (function
X                (lambda (x)
X                  (calcFunc-frac x tol)))
X                   (cdr a))))
X    ((Math-messy-integerp a)
X     (math-trunc a))
X    ((Math-negp a)
X     (math-neg (calcFunc-frac (math-neg a) tol)))
X    ((not (eq (car a) 'float))
X     (if (math-infinitep a)
X         a
X       (if (math-provably-integerp a)
X           a
X         (math-reject-arg a 'numberp))))
X    ((integerp tol)
X     (if (<= tol 0)
X         (setq tol (+ tol calc-internal-prec)))
X     (calcFunc-frac a (list 'float 5
X                (- (+ (math-numdigs (nth 1 a))
X                      (nth 2 a))
X                   (1+ tol)))))
X    ((not (eq (car tol) 'float))
X     (if (Math-realp tol)
X         (calcFunc-frac a (math-float tol))
X       (math-reject-arg tol 'realp)))
X    ((Math-negp tol)
X     (calcFunc-frac a (math-neg tol)))
X    ((Math-zerop tol)
X     (calcFunc-frac a 0))
X    ((not (math-lessp-float tol '(float 1 0)))
X     (math-trunc a))
X    ((Math-zerop a)
X     0)
X    (t
X     (let ((cfrac (math-continued-fraction a tol))
X           (calc-prefer-frac t))
X       (math-eval-continued-fraction cfrac))))
)
X
(defun math-continued-fraction (a tol)
X  (let ((calc-internal-prec (+ calc-internal-prec 2)))
X    (let ((cfrac nil)
X      (aa a)
X      (calc-prefer-frac nil)
X      int)
X      (while (or (null cfrac)
X         (and (not (Math-zerop aa))
X              (not (math-lessp-float
X                (math-abs
X                 (math-sub a
X                       (let ((f (math-eval-continued-fraction
X                         cfrac)))
X                     (math-working "Fractionalize" f)
X                     f)))
X                tol))))
X    (setq int (math-trunc aa)
X          aa (math-sub aa int)
X          cfrac (cons int cfrac))
X    (or (Math-zerop aa)
X        (setq aa (math-div 1 aa))))
X      cfrac))
)
X
(defun math-eval-continued-fraction (cf)
X  (let ((n (car cf))
X    (d 1)
X    temp)
X    (while (setq cf (cdr cf))
X      (setq temp (math-add (math-mul (car cf) n) d)
X        d n
X        n temp))
X    (math-div n d))
)
X
X
X
(defun calcFunc-fdiv (a b)   ; [R I I] [Public]
X  (if (Math-num-integerp a)
X      (if (Math-num-integerp b)
X      (if (Math-zerop b)
X          (math-reject-arg a "*Division by zero")
X        (math-make-frac (math-trunc a) (math-trunc b)))
X    (math-reject-arg b 'integerp))
X    (math-reject-arg a 'integerp))
)
X
SHAR_EOF
chmod 0644 calc-frac.el ||
echo 'restore of calc-frac.el failed'
Wc_c="`wc -c < 'calc-frac.el'`"
test 6304 -eq "$Wc_c" ||
    echo 'calc-frac.el: original size 6304, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
# ============= calc-funcs.el ==============
if test -f 'calc-funcs.el' -a X"$1" != X"-c"; then
    echo 'x - skipping calc-funcs.el (File already exists)'
    rm -f _shar_wnt_.tmp
else
> _shar_wnt_.tmp
echo 'x - extracting calc-funcs.el (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'calc-funcs.el' &&
;; Calculator for GNU Emacs, part II [calc-funcs.el]
;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
;; Written by Dave Gillespie, [e-mail].
X
;; This file is part of GNU Emacs.
X
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.  Refer to the GNU Emacs General Public
;; License for full details.
X
;; Everyone is granted permission to copy, modify and redistribute
;; GNU Emacs, but only under the conditions described in the
;; GNU Emacs General Public License.   A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities.  It should be in a
;; file named COPYING.  Among other things, the copyright notice
;; and this notice must be preserved on all copies.
X
X
X
;; This file is autoloaded from calc-ext.el.
(require 'calc-ext)
X
(require 'calc-macs)
X
(defun calc-Need-calc-funcs () nil)
X
X
(defun calc-inc-gamma (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (if (calc-is-hyperbolic)
X       (calc-binary-op "gamG" 'calcFunc-gammaG arg)
X     (calc-binary-op "gamQ" 'calcFunc-gammaQ arg))
X       (if (calc-is-hyperbolic)
X       (calc-binary-op "gamg" 'calcFunc-gammag arg)
X     (calc-binary-op "gamP" 'calcFunc-gammaP arg))))
)
X
(defun calc-erf (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (calc-unary-op "erfc" 'calcFunc-erfc arg)
X     (calc-unary-op "erf" 'calcFunc-erf arg)))
)
X
(defun calc-erfc (arg)
X  (interactive "P")
X  (calc-invert-func)
X  (calc-erf arg)
)
X
(defun calc-beta (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "beta" 'calcFunc-beta arg))
)
X
(defun calc-inc-beta ()
X  (interactive)
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-enter-result 3 "betB" (cons 'calcFunc-betaB (calc-top-list-n 3)))
X     (calc-enter-result 3 "betI" (cons 'calcFunc-betaI (calc-top-list-n 3)))))
)
X
(defun calc-bessel-J (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "besJ" 'calcFunc-besJ arg))
)
X
(defun calc-bessel-Y (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (calc-binary-op "besY" 'calcFunc-besY arg))
)
X
(defun calc-bernoulli-number (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-binary-op "bern" 'calcFunc-bern arg)
X     (calc-unary-op "bern" 'calcFunc-bern arg)))
)
X
(defun calc-euler-number (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-binary-op "eulr" 'calcFunc-euler arg)
X     (calc-unary-op "eulr" 'calcFunc-euler arg)))
)
X
(defun calc-stirling-number (arg)
X  (interactive "P")
X  (calc-slow-wrapper
X   (if (calc-is-hyperbolic)
X       (calc-binary-op "str2" 'calcFunc-stir2 arg)
X     (calc-binary-op "str1" 'calcFunc-stir1 arg)))
)
X
(defun calc-utpb ()
X  (interactive)
X  (calc-prob-dist "b" 3)
)
X
(defun calc-utpc ()
X  (interactive)
X  (calc-prob-dist "c" 2)
)
X
(defun calc-utpf ()
X  (interactive)
X  (calc-prob-dist "f" 3)
)
X
(defun calc-utpn ()
X  (interactive)
X  (calc-prob-dist "n" 3)
)
X
(defun calc-utpp ()
X  (interactive)
X  (calc-prob-dist "p" 2)
)
X
(defun calc-utpt ()
X  (interactive)
X  (calc-prob-dist "t" 2)
)
X
(defun calc-prob-dist (letter nargs)
X  (calc-slow-wrapper
X   (if (calc-is-inverse)
X       (calc-enter-result nargs (concat "ltp" letter)
X              (append (list (intern (concat "calcFunc-ltp" letter))
X                    (calc-top-n 1))
X                  (calc-top-list-n (1- nargs) 2)))
X     (calc-enter-result nargs (concat "utp" letter)
X            (append (list (intern (concat "calcFunc-utp" letter))
X                      (calc-top-n 1))
X                (calc-top-list-n (1- nargs) 2)))))
)
X
X
X
X
;;; Sources:  Numerical Recipes, Press et al;
;;;           Handbook of Mathematical Functions, Abramowitz & Stegun.
X
X
;;; Gamma function.
X
(defun calcFunc-gamma (x)
X  (or (math-numberp x) (math-reject-arg x 'numberp))
X  (calcFunc-fact (math-add x -1))
)
X
(defun math-gammap1-raw (x &optional fprec nfprec)   ; compute gamma(1 + x)
X  (or fprec
X      (setq fprec (math-float calc-internal-prec)
X        nfprec (math-float (- calc-internal-prec))))
X  (cond ((math-lessp-float (calcFunc-re x) fprec)
X     (if (math-lessp-float (calcFunc-re x) nfprec)
X         (math-neg (math-div
X            (math-pi)
X            (math-mul (math-gammap1-raw
X                   (math-add (math-neg x)
X                         '(float -1 0))
X                   fprec nfprec)
X                  (math-sin-raw
X                   (math-mul (math-pi) x)))))
X       (let ((xplus1 (math-add x '(float 1 0))))
X         (math-div (math-gammap1-raw xplus1 fprec nfprec) xplus1))))
X    ((and (math-realp x)
X          (math-lessp-float '(float 736276 0) x))
X     (math-overflow))
X    (t   ; re(x) now >= 10.0
X     (let ((xinv (math-div 1 x))
X           (lnx (math-ln-raw x)))
X       (math-mul (math-sqrt-two-pi)
X             (math-exp-raw
X              (math-gamma-series
X               (math-sub (math-mul (math-add x '(float 5 -1))
X                       lnx)
X                 x)
X               xinv
X               (math-sqr xinv)
X               '(float 0 0)
X               2))))))
)
X
(defun math-gamma-series (sum x xinvsqr oterm n)
X  (math-working "gamma" sum)
X  (let* ((bn (math-bernoulli-number n))
X     (term (math-mul (math-div-float (math-float (nth 1 bn))
X                     (math-float (* (nth 2 bn)
X                            (* n (1- n)))))
X             x))
X     (next (math-add sum term)))
X    (if (math-nearly-equal sum next)
X    next
X      (if (> n (* 2 calc-internal-prec))
X      (progn
X        ;; Need this because series eventually diverges for large enough n.
X        (calc-record-why
X         "*Gamma computation stopped early, not all digits may be valid")
X        next)
X    (math-gamma-series next (math-mul x xinvsqr) xinvsqr term (+ n 2)))))
)
X
X
;;; Incomplete gamma function.
X
(defun calcFunc-gammaP (a x)
X  (if (equal x '(var inf var-inf))
X      '(float 1 0)
X    (math-inexact-result)
X    (or (Math-numberp a) (math-reject-arg a 'numberp))
X    (or (math-numberp x) (math-reject-arg x 'numberp))
X    (if (and (math-num-integerp a)
X         (integerp (setq a (math-trunc a)))
X         (> a 0) (< a 20))
X    (math-sub 1 (calcFunc-gammaQ a x))
X      (let ((math-current-gamma-value (calcFunc-gamma a)))
X    (math-div (calcFunc-gammag a x) math-current-gamma-value))))
)
X
(defun calcFunc-gammaQ (a x)
X  (if (equal x '(var inf var-inf))
X      '(float 0 0)
X    (math-inexact-result)
X    (or (Math-numberp a) (math-reject-arg a 'numberp))
X    (or (math-numberp x) (math-reject-arg x 'numberp))
X    (if (and (math-num-integerp a)
X         (integerp (setq a (math-trunc a)))
X         (> a 0) (< a 20))
X    (let ((n 0)
X          (sum '(float 1 0))
X          (term '(float 1 0)))
X      (math-with-extra-prec 1
X        (while (< (setq n (1+ n)) a)
X          (setq term (math-div (math-mul term x) n)
X            sum (math-add sum term))
X          (math-working "gamma" sum))
X        (math-mul sum (calcFunc-exp (math-neg x)))))
X      (let ((math-current-gamma-value (calcFunc-gamma a)))
X    (math-div (calcFunc-gammaG a x) math-current-gamma-value))))
)
X
(defun calcFunc-gammag (a x)
X  (if (equal x '(var inf var-inf))
X      (calcFunc-gamma a)
X    (math-inexact-result)
X    (or (Math-numberp a) (math-reject-arg a 'numberp))
X    (or (Math-numberp x) (math-reject-arg x 'numberp))
X    (math-with-extra-prec 2
X      (setq a (math-float a))
X      (setq x (math-float x))
X      (if (or (math-negp (calcFunc-re a))
X          (math-lessp-float (calcFunc-re x)
X                (math-add-float (calcFunc-re a)
X                        '(float 1 0))))
X      (math-inc-gamma-series a x)
X    (math-sub (or math-current-gamma-value (calcFunc-gamma a))
X          (math-inc-gamma-cfrac a x)))))
)
(setq math-current-gamma-value nil)
X
(defun calcFunc-gammaG (a x)
X  (if (equal x '(var inf var-inf))
X      '(float 0 0)
X    (math-inexact-result)
X    (or (Math-numberp a) (math-reject-arg a 'numberp))
X    (or (Math-numberp x) (math-reject-arg x 'numberp))
X    (math-with-extra-prec 2
X      (setq a (math-float a))
X      (setq x (math-float x))
X      (if (or (math-negp (calcFunc-re a))
X          (math-lessp-float (calcFunc-re x)
X                (math-add-float (math-abs-approx a)
X                        '(float 1 0))))
X      (math-sub (or math-current-gamma-value (calcFunc-gamma a))
X            (math-inc-gamma-series a x))
X    (math-inc-gamma-cfrac a x))))
)
X
(defun math-inc-gamma-series (a x)
X  (if (Math-zerop x)
X      '(float 0 0)
X    (math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x))
X          (math-with-extra-prec 2
X        (let ((start (math-div '(float 1 0) a)))
X          (math-inc-gamma-series-step start start a x)))))
)
X
(defun math-inc-gamma-series-step (sum term a x)
X  (math-working "gamma" sum)
X  (setq a (math-add a '(float 1 0))
X    term (math-div (math-mul term x) a))
X  (let ((next (math-add sum term)))
X    (if (math-nearly-equal sum next)
X    next
X      (math-inc-gamma-series-step next term a x)))
)
X
(defun math-inc-gamma-cfrac (a x)
X  (if (Math-zerop x)
X      (or math-current-gamma-value (calcFunc-gamma a))
X    (math-mul (math-exp-raw (math-sub (math-mul a (math-ln-raw x)) x))
X          (math-inc-gamma-cfrac-step '(float 1 0) x
X                     '(float 0 0) '(float 1 0)
X                     '(float 1 0) '(float 1 0) '(float 0 0)
X                     a x)))
)
X
(defun math-inc-gamma-cfrac-step (a0 a1 b0 b1 n fac g a x)
X  (let ((ana (math-sub n a))
X    (anf (math-mul n fac)))
X    (setq n (math-add n '(float 1 0))
X      a0 (math-mul (math-add a1 (math-mul a0 ana)) fac)
X      b0 (math-mul (math-add b1 (math-mul b0 ana)) fac)
X      a1 (math-add (math-mul x a0) (math-mul anf a1))
X      b1 (math-add (math-mul x b0) (math-mul anf b1)))
X    (if (math-zerop a1)
X    (math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac g a x)
X      (setq fac (math-div '(float 1 0) a1))
X      (let ((next (math-mul b1 fac)))
X    (math-working "gamma" next)
X    (if (math-nearly-equal next g)
X        next
X      (math-inc-gamma-cfrac-step a0 a1 b0 b1 n fac next a x)))))
)
X
X
;;; Error function.
X
(defun calcFunc-erf (x)
X  (if (equal x '(var inf var-inf))
X      '(float 1 0)
X    (if (equal x '(neg (var inf var-inf)))
X    '(float -1 0)
X      (let ((math-current-gamma-value (math-sqrt-pi)))
X    (math-to-same-complex-quad
X     (math-div (calcFunc-gammag '(float 5 -1)
X                    (math-sqr (math-to-complex-quad-one x)))
X           math-current-gamma-value)
X     x))))
)
X
(defun calcFunc-erfc (x)
X  (if (equal x '(var inf var-inf))
X      '(float 0 0)
X    (if (math-posp x)
X    (let ((math-current-gamma-value (math-sqrt-pi)))
X      (math-div (calcFunc-gammaG '(float 5 -1) (math-sqr x))
X            math-current-gamma-value))
X      (math-add '(float 1 0) (calcFunc-erf (math-neg x)))))
)
X
(defun math-to-complex-quad-one (x)
X  (if (eq (car-safe x) 'polar) (setq x (math-complex x)))
X  (if (eq (car-safe x) 'cplx)
X      (list 'cplx (math-abs (nth 1 x)) (math-abs (nth 2 x)))
X    x)
)
X
(defun math-to-same-complex-quad (x y)
X  (if (eq (car-safe y) 'cplx)
X      (if (eq (car-safe x) 'cplx)
X      (list 'cplx
X        (if (math-negp (nth 1 y)) (math-neg (nth 1 x)) (nth 1 x))
X        (if (math-negp (nth 2 y)) (math-neg (nth 2 x)) (nth 2 x)))
X    (if (math-negp (nth 1 y)) (math-neg x) x))
X    (if (math-negp y)
X    (if (eq (car-safe x) 'cplx)
X        (list 'cplx (math-neg (nth 1 x)) (nth 2 x))
X      (math-neg x))
X      x))
)
X
X
;;; Beta function.
X
(defun calcFunc-beta (a b)
X  (if (math-num-integerp a)
X      (let ((am (math-add a -1)))
X    (or (math-numberp b) (math-reject-arg b 'numberp))
X    (math-div 1 (math-mul b (calcFunc-choose (math-add b am) am))))
X    (if (math-num-integerp b)
X    (calcFunc-beta b a)
X      (math-div (math-mul (calcFunc-gamma a) (calcFunc-gamma b))
X        (calcFunc-gamma (math-add a b)))))
)
X
X
;;; Incomplete beta function.
X
(defun calcFunc-betaI (x a b)
X  (cond ((math-zerop x)
X     '(float 0 0))
X    ((math-equal-int x 1)
X     '(float 1 0))
X    ((or (math-zerop a)
X         (and (math-num-integerp a)
X          (math-negp a)))
X     (if (or (math-zerop b)
X         (and (math-num-integerp b)
X              (math-negp b)))
X         (math-reject-arg b 'range)
X       '(float 1 0)))
X    ((or (math-zerop b)
X         (and (math-num-integerp b)
X          (math-negp b)))
X     '(float 0 0))
X    ((not (math-numberp a)) (math-reject-arg a 'numberp))
X    ((not (math-numberp b)) (math-reject-arg b 'numberp))
X    ((math-inexact-result))
X    (t (let ((math-current-beta-value (calcFunc-beta a b)))
X         (math-div (calcFunc-betaB x a b) math-current-beta-value))))
)
X
(defun calcFunc-betaB (x a b)
X  (cond
X   ((math-zerop x)
X    '(float 0 0))
X   ((math-equal-int x 1)
X    (calcFunc-beta a b))
X   ((not (math-numberp x)) (math-reject-arg x 'numberp))
X   ((not (math-numberp a)) (math-reject-arg a 'numberp))
X   ((not (math-numberp b)) (math-reject-arg b 'numberp))
X   ((math-zerop a) (math-reject-arg a 'nonzerop))
X   ((math-zerop b) (math-reject-arg b 'nonzerop))
X   ((and (math-num-integerp b)
X     (if (math-negp b)
X         (math-reject-arg b 'range)
X       (Math-natnum-lessp (setq b (math-trunc b)) 20)))
X    (and calc-symbolic-mode (or (math-floatp a) (math-floatp b))
X     (math-inexact-result))
X    (math-mul
X     (math-with-extra-prec 2
X       (let* ((i 0)
X          (term 1)
X          (sum (math-div term a)))
X     (while (< (setq i (1+ i)) b)
X       (setq term (math-mul (math-div (math-mul term (- i b)) i) x)
X         sum (math-add sum (math-div term (math-add a i))))
X       (math-working "beta" sum))
X     sum))
X     (math-pow x a)))
X   ((and (math-num-integerp a)
X     (if (math-negp a)
X         (math-reject-arg a 'range)
X       (Math-natnum-lessp (setq a (math-trunc a)) 20)))
X    (math-sub (or math-current-beta-value (calcFunc-beta a b))
X          (calcFunc-betaB (math-sub 1 x) b a)))
X   (t
X    (math-inexact-result)
X    (math-with-extra-prec 2
X      (setq x (math-float x))
X      (setq a (math-float a))
X      (setq b (math-float b))
X      (let ((bt (math-exp-raw (math-add (math-mul a (math-ln-raw x))
X                    (math-mul b (math-ln-raw
X                             (math-sub '(float 1 0)
X                                   x)))))))
X    (if (Math-lessp x (math-div (math-add a '(float 1 0))
X                    (math-add (math-add a b) '(float 2 0))))
X        (math-div (math-mul bt (math-beta-cfrac a b x)) a)
X      (math-sub (or math-current-beta-value (calcFunc-beta a b))
X            (math-div (math-mul bt
X                    (math-beta-cfrac b a (math-sub 1 x)))
X                  b)))))))
)
(setq math-current-beta-value nil)
X
(defun math-beta-cfrac (a b x)
X  (let ((qab (math-add a b))
X    (qap (math-add a '(float 1 0)))
X    (qam (math-add a '(float -1 0))))
X    (math-beta-cfrac-step '(float 1 0)
X              (math-sub '(float 1 0)
X                    (math-div (math-mul qab x) qap))
X              '(float 1 0) '(float 1 0)
X              '(float 1 0)
X              qab qap qam a b x))
)
X
(defun math-beta-cfrac-step (az bz am bm m qab qap qam a b x)
X  (let* ((two-m (math-mul m '(float 2 0)))
X     (d (math-div (math-mul (math-mul (math-sub b m) m) x)
X              (math-mul (math-add qam two-m) (math-add a two-m))))
X     (ap (math-add az (math-mul d am)))
X     (bp (math-add bz (math-mul d bm)))
X     (d2 (math-neg
X          (math-div (math-mul (math-mul (math-add a m) (math-add qab m)) x)
X            (math-mul (math-add qap two-m) (math-add a two-m)))))
X     (app (math-add ap (math-mul d2 az)))
X     (bpp (math-add bp (math-mul d2 bz)))
X     (next (math-div app bpp)))
X    (math-working "beta" next)
X    (if (math-nearly-equal next az)
X    next
X      (math-beta-cfrac-step next '(float 1 0)
X                (math-div ap bpp) (math-div bp bpp)
X                (math-add m '(float 1 0))
X                qab qap qam a b x)))
)
X
X
;;; Bessel functions.
X
;;; Should generalize this to handle arbitrary precision!
X
(defun calcFunc-besJ (v x)
X  (or (math-numberp v) (math-reject-arg v 'numberp))
X  (or (math-numberp x) (math-reject-arg x 'numberp))
X  (let ((calc-internal-prec (min 8 calc-internal-prec)))
X    (math-with-extra-prec 3
X      (setq x (math-float (math-normalize x)))
X      (setq v (math-float (math-normalize v)))
X      (cond ((math-zerop x)
X         (if (math-zerop v)
X         '(float 1 0)
X           '(float 0 0)))
X        ((math-inexact-result))
X        ((not (math-num-integerp v))
X         (let ((start (math-div 1 (calcFunc-fact v))))
X           (math-mul (math-besJ-series start start
X                       0
X                       (math-mul '(float -25 -2)
X                             (math-sqr x))
X                       v)
X             (math-pow (math-div x 2) v))))
X        ((math-negp (setq v (math-trunc v)))
X         (if (math-oddp v)
X         (math-neg (calcFunc-besJ (math-neg v) x))
X           (calcFunc-besJ (math-neg v) x)))
X        ((eq v 0)
X         (math-besJ0 x))
X        ((eq v 1)
X         (math-besJ1 x))
X        ((Math-lessp v (math-abs-approx x))
X         (let ((j 0)
X           (bjm (math-besJ0 x))
X           (bj (math-besJ1 x))
X           (two-over-x (math-div 2 x))
X           bjp)
X           (while (< (setq j (1+ j)) v)
X         (setq bjp (math-sub (math-mul (math-mul j two-over-x) bj)
X                     bjm)
X               bjm bj
X               bj bjp))
X           bj))
X        (t
X         (if (Math-lessp 100 v) (math-reject-arg v 'range))
X         (let* ((j (logior (+ v (math-isqrt-small (* 40 v))) 1))
X            (two-over-x (math-div 2 x))
X            (jsum nil)
X            (bjp '(float 0 0))
X            (sum '(float 0 0))
X            (bj '(float 1 0))
X            bjm ans)
X           (while (> (setq j (1- j)) 0)
X         (setq bjm (math-sub (math-mul (math-mul j two-over-x) bj)
X                     bjp)
X               bjp bj
X               bj bjm)
X         (if (> (nth 2 (math-abs-approx bj)) 10)
X             (setq bj (math-mul bj '(float 1 -10))
X               bjp (math-mul bjp '(float 1 -10))
X               ans (and ans (math-mul ans '(float 1 -10)))
X               sum (math-mul sum '(float 1 -10))))
X         (or (setq jsum (not jsum))
X             (setq sum (math-add sum bj)))
X         (if (= j v)
X             (setq ans bjp)))
X           (math-div ans (math-sub (math-mul 2 sum) bj)))))))
)
X
(defun math-besJ-series (sum term k zz vk)
X  (math-working "besJ" sum)
X  (setq k (1+ k)
X    vk (math-add 1 vk)
X    term (math-div (math-mul term zz) (math-mul k vk)))
X  (let ((next (math-add sum term)))
X    (if (math-nearly-equal next sum)
X    next
X      (math-besJ-series next term k zz vk)))
)
X
(defun math-besJ0 (x &optional yflag)
X  (cond ((and (not yflag) (math-negp (calcFunc-re x)))
X     (math-besJ0 (math-neg x)))
X    ((Math-lessp '(float 8 0) (math-abs-approx x))
X     (let* ((z (math-div '(float 8 0) x))
X        (y (math-sqr z))
X        (xx (math-add x '(float (bigneg 164 398 785) -9)))
X        (a1 (math-poly-eval y
X                    '((float (bigpos 211 887 093 2) -16)
X                      (float (bigneg 639 370 073 2) -15)
X                      (float (bigpos 407 510 734 2) -14)
X                      (float (bigneg 627 628 098 1) -12)
X                      (float 1 0))))
X        (a2 (math-poly-eval y
X                    '((float (bigneg 152 935 934) -16)
X                      (float (bigpos 161 095 621 7) -16)
X                      (float (bigneg 651 147 911 6) -15)
X                      (float (bigpos 765 488 430 1) -13)
X                      (float (bigneg 995 499 562 1) -11))))
X        (sc (math-sin-cos-raw xx)))
X           (if yflag
X           (setq sc (cons (math-neg (cdr sc)) (car sc))))
X           (math-mul (math-sqrt
X              (math-div '(float (bigpos 722 619 636) -9) x))
X             (math-sub (math-mul (cdr sc) a1)
X                   (math-mul (car sc) (math-mul z a2))))))
X     (t
X      (let ((y (math-sqr x)))
X        (math-div (math-poly-eval y
X                      '((float (bigneg 456 052 849 1) -7)
X                    (float (bigpos 017 233 739 7) -5)
X                    (float (bigneg 418 442 121 1) -2)
X                    (float (bigpos 407 196 516 6) -1)
X                    (float (bigneg 354 590 362 13) 0)
X                    (float (bigpos 574 490 568 57) 0)))
X              (math-poly-eval y
X                      '((float 1 0)
X                    (float (bigpos 712 532 678 2) -7)
X                    (float (bigpos 853 264 927 5) -5)
X                    (float (bigpos 718 680 494 9) -3)
X                    (float (bigpos 985 532 029 1) 0)
X                    (float (bigpos 411 490 568 57) 0)))))))
)
X
(defun math-besJ1 (x &optional yflag)
X  (cond ((and (math-negp (calcFunc-re x)) (not yflag))
X     (math-neg (math-besJ1 (math-neg x))))
X    ((Math-lessp '(float 8 0) (math-abs-approx x))
X     (let* ((z (math-div '(float 8 0) x))
X        (y (math-sqr z))
X        (xx (math-add x '(float (bigneg 491 194 356 2) -9)))
X        (a1 (math-poly-eval y
X                    '((float (bigneg 019 337 240) -15)
X                      (float (bigpos 174 520 457 2) -15)
X                      (float (bigneg 496 396 516 3) -14)
X                      (float 183105 -8)
X                      (float 1 0))))
X        (a2 (math-poly-eval y
X                    '((float (bigpos 412 787 105) -15)
X                      (float (bigneg 987 228 88) -14)
X                      (float (bigpos 096 199 449 8) -15)
X                      (float (bigneg 873 690 002 2) -13)
X                      (float (bigpos 995 499 687 4) -11))))
X        (sc (math-sin-cos-raw xx)))
X       (if yflag
X           (setq sc (cons (math-neg (cdr sc)) (car sc)))
X         (if (math-negp x)
X         (setq sc (cons (math-neg (car sc)) (math-neg (cdr sc))))))
X       (math-mul (math-sqrt (math-div '(float (bigpos 722 619 636) -9) x))
X             (math-sub (math-mul (cdr sc) a1)
X                   (math-mul (car sc) (math-mul z a2))))))
X    (t
X     (let ((y (math-sqr x)))
X       (math-mul
X        x
X        (math-div (math-poly-eval y
X                      '((float (bigneg 606 036 016 3) -8)
X                    (float (bigpos 826 044 157) -4)
X                    (float (bigneg 439 611 972 2) -3)
X                    (float (bigpos 531 968 423 2) -1)
X                    (float (bigneg 235 059 895 7) 0)
X                    (float (bigpos 232 614 362 72) 0)))
X              (math-poly-eval y
X                      '((float 1 0)
X                    (float (bigpos 397 991 769 3) -7)
X                    (float (bigpos 394 743 944 9) -5)
X                    (float (bigpos 474 330 858 1) -2)
X                    (float (bigpos 178 535 300 2) 0)
X                    (float (bigpos 442 228 725 144)
X                           0))))))))
)
X
(defun calcFunc-besY (v x)
X  (math-inexact-result)
X  (or (math-numberp v) (math-reject-arg v 'numberp))
X  (or (math-numberp x) (math-reject-arg x 'numberp))
X  (let ((calc-internal-prec (min 8 calc-internal-prec)))
X    (math-with-extra-prec 3
X      (setq x (math-float (math-normalize x)))
X      (setq v (math-float (math-normalize v)))
X      (cond ((not (math-num-integerp v))
X         (let ((sc (math-sin-cos-raw (math-mul v (math-pi)))))
X           (math-div (math-sub (math-mul (calcFunc-besJ v x) (cdr sc))
X                   (calcFunc-besJ (math-neg v) x))
X             (car sc))))
X        ((math-negp (setq v (math-trunc v)))
X         (if (math-oddp v)
X         (math-neg (calcFunc-besY (math-neg v) x))
X           (calcFunc-besY (math-neg v) x)))
X        ((eq v 0)
X         (math-besY0 x))
X        ((eq v 1)
X         (math-besY1 x))
X        (t
X         (let ((j 0)
X           (bym (math-besY0 x))
X           (by (math-besY1 x))
X           (two-over-x (math-div 2 x))
X           byp)
X           (while (< (setq j (1+ j)) v)
X         (setq byp (math-sub (math-mul (math-mul j two-over-x) by)
X                     bym)
X               bym by
SHAR_EOF
true || echo 'restore of calc-funcs.el failed'
fi
echo 'End of  part 16'
echo 'File calc-funcs.el is continued in part 17'
echo 17 > _shar_seq_.tmp
exit 0
exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].